home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #15
/
Monster Media Number 15 (Monster Media)(July 1996).ISO
/
prog_bas
/
vbcal32.zip
/
VBCAL32.FRM
< prev
next >
Wrap
Text File
|
1996-04-17
|
19KB
|
685 lines
VERSION 4.00
Begin VB.Form frmcalendar
BorderStyle = 1 'Fixed Single
Caption = "VBCalendar"
ClientHeight = 2715
ClientLeft = 1350
ClientTop = 1695
ClientWidth = 4275
ControlBox = 0 'False
BeginProperty Font
name = "MS Sans Serif"
charset = 0
weight = 700
size = 8.25
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 3120
Icon = "VBCal32.frx":0000
Left = 1290
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 2715
ScaleWidth = 4275
Top = 1350
Width = 4395
Begin VB.CommandButton cmdAbout
Caption = "About"
Height = 255
Left = 3000
TabIndex = 5
Top = 1920
Width = 1215
End
Begin VB.ComboBox cboyear
Height = 315
Left = 2880
Style = 2 'Dropdown List
TabIndex = 3
Top = 240
Width = 1215
End
Begin VB.ComboBox cbomonth
Height = 315
Left = 120
Style = 2 'Dropdown List
TabIndex = 1
Top = 240
Width = 2415
End
Begin VB.CommandButton cmdcancel
Appearance = 0 'Flat
BackColor = &H80000005&
Cancel = -1 'True
Caption = "E&xit"
Height = 345
Left = 3000
TabIndex = 39
Top = 2280
Width = 1215
End
Begin VB.CommandButton cmdok
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "&OK"
Default = -1 'True
Height = 345
Left = 3000
TabIndex = 4
Top = 1440
Width = 1215
End
Begin VB.Label lbldate
Alignment = 2 'Center
BackStyle = 0 'Transparent
ForeColor = &H00800000&
Height = 615
Left = 2880
TabIndex = 38
Top = 840
Width = 1215
End
Begin VB.Label lblday
Alignment = 2 'Center
BackStyle = 0 'Transparent
ForeColor = &H00800000&
Height = 255
Left = 2880
TabIndex = 37
Top = 645
Width = 1215
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "29"
Height = 285
Index = 28
Left = 240
TabIndex = 7
Top = 2280
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "30"
Height = 285
Index = 29
Left = 600
TabIndex = 8
Top = 2280
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "31"
Height = 285
Index = 30
Left = 960
TabIndex = 9
Top = 2280
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "16"
Height = 285
Index = 15
Left = 600
TabIndex = 10
Top = 1560
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "17"
Height = 285
Index = 16
Left = 960
TabIndex = 11
Top = 1560
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "18"
Height = 285
Index = 17
Left = 1320
TabIndex = 12
Top = 1560
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "19"
Height = 285
Index = 18
Left = 1680
TabIndex = 13
Top = 1560
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "20"
Height = 285
Index = 19
Left = 2040
TabIndex = 36
Top = 1560
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "21"
Height = 285
Index = 20
Left = 2400
TabIndex = 35
Top = 1560
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "15"
Height = 285
Index = 14
Left = 240
TabIndex = 34
Top = 1560
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "23"
Height = 285
Index = 22
Left = 600
TabIndex = 33
Top = 1920
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "24"
Height = 285
Index = 23
Left = 960
TabIndex = 32
Top = 1920
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "25"
Height = 285
Index = 24
Left = 1320
TabIndex = 31
Top = 1920
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "26"
Height = 285
Index = 25
Left = 1680
TabIndex = 30
Top = 1920
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "27"
Height = 285
Index = 26
Left = 2040
TabIndex = 29
Top = 1920
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "28"
Height = 285
Index = 27
Left = 2400
TabIndex = 28
Top = 1920
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "22"
Height = 285
Index = 21
Left = 240
TabIndex = 27
Top = 1920
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "9"
Height = 285
Index = 8
Left = 600
TabIndex = 26
Top = 1200
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "10"
Height = 285
Index = 9
Left = 960
TabIndex = 25
Top = 1200
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "11"
Height = 285
Index = 10
Left = 1320
TabIndex = 24
Top = 1200
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "12"
Height = 285
Index = 11
Left = 1680
TabIndex = 23
Top = 1200
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "13"
Height = 285
Index = 12
Left = 2040
TabIndex = 22
Top = 1200
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "14"
Height = 285
Index = 13
Left = 2400
TabIndex = 21
Top = 1200
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "8"
Height = 285
Index = 7
Left = 240
TabIndex = 20
Top = 1200
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "2"
Height = 285
Index = 1
Left = 600
TabIndex = 19
Top = 840
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "3"
Height = 285
Index = 2
Left = 960
TabIndex = 18
Top = 840
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "4"
Height = 285
Index = 3
Left = 1320
TabIndex = 17
Top = 840
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "5"
Height = 285
Index = 4
Left = 1680
TabIndex = 16
Top = 840
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "6"
Height = 285
Index = 5
Left = 2040
TabIndex = 15
Top = 840
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "7"
Height = 285
Index = 6
Left = 2400
TabIndex = 14
Top = 840
Width = 300
End
Begin VB.Label lblnumber
Alignment = 2 'Center
BackStyle = 0 'Transparent
Caption = "1"
Height = 285
Index = 0
Left = 240
TabIndex = 6
Top = 840
Width = 300
End
Begin VB.Shape Shape1
Height = 1935
Left = 120
Top = 720
Width = 2655
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "&Year"
Height = 255
Index = 1
Left = 2880
TabIndex = 2
Top = 0
Width = 495
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "&Month"
Height = 255
Index = 0
Left = 120
TabIndex = 0
Top = 0
Width = 615
End
End
Attribute VB_Name = "frmcalendar"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
'This code has been developed for EVERYONE'S use
' don't re-distribute this without ALL original files!!
'Phil Jones 1994
Option Explicit
Dim selectedate%
Private Sub cbomonth_click()
Call setday
Call lblnumber_click(selectedate% - 1)
End Sub
Private Sub cboyear_Click()
Static once% ' get rid of first click event
If Not once Then
once = True
Exit Sub
End If
Call cbomonth_click
End Sub
Private Sub checkdate(month1%, year1%)
Dim i%, value%, date1$
For i% = 28 To 32
date1$ = (Str$(month1%) + "/" + Str$(i%) + "/" + Str$(year1%))
If IsDate(date1$) Then
value% = i%
Else
Call displaynumbers(value%)
Exit Sub
End If
Next i%
End Sub
Private Sub cmdAbout_Click()
frmAbout.Show
End Sub
Private Sub cmdcancel_Click()
Unload frmcalendar
End Sub
Private Sub cmdok_Click()
Dim month1%, day1%, year1%, date1$
day1% = selectedate%
month1% = cbomonth.ListIndex + 1
year1% = cboyear.ListIndex + 1960
date1$ = (Str$(month1%) + "/" + Str$(day1%) + "/" + Str$(year1%))
date1$ = Format$(date1$, "general date")
MsgBox Format$(date1$, "long date") 'do whatever here to pass the date where
'you need it!
End Sub
Private Function determinemonth%()
Dim i%
i% = cbomonth.ListIndex 'which month is selected?
determinemonth% = i% + 1
End Function
Private Function determineyear%()
Dim i%
i% = cboyear.ListIndex 'which year was selected?
If i% = -1 Then Exit Function 'problem!!
determineyear% = CInt(Trim(cboyear.List(i%)))
End Function
Private Sub displaynumbers(number%)
Dim i%
For i% = 28 To 30
lblnumber(i%).Visible = False
Next i%
For i% = 28 To number% - 1
lblnumber(i%).Visible = True
Next i%
End Sub
Private Sub fillcbomonth()
cbomonth.AddItem "January"
cbomonth.AddItem "February"
cbomonth.AddItem "March"
cbomonth.AddItem "April"
cbomonth.AddItem "May"
cbomonth.AddItem "June"
cbomonth.AddItem "July"
cbomonth.AddItem "August"
cbomonth.AddItem "September"
cbomonth.AddItem "October"
cbomonth.AddItem "November"
cbomonth.AddItem "December"
End Sub
Private Sub fillcboyear()
Dim i%
For i% = 1960 To 2060 'put whatever years tyou want here,
cboyear.AddItem Str$(i%) 'but don't forget to also change the code in setdate
Next i%
End Sub
Private Sub Form_Load()
selectedate% = CInt(Format$(Now, "dd"))
'fill month combo box
Call fillcbomonth
'fill year combo box
Call fillcboyear
'put current date and year im combo box
Call setdate
'set current name for day
Dim r%, caption1$
r% = WeekDay(Format$(Now, "general date"))
If r% = 1 Then
caption1$ = "Sunday"
ElseIf r% = 2 Then
caption1 = "Monday"
ElseIf r% = 3 Then
caption1 = "Tuesday"
ElseIf r% = 4 Then
caption1 = "Wednesday"
ElseIf r% = 5 Then
caption1 = "Thursday"
ElseIf r% = 6 Then
caption1 = "Friday"
Else
caption1 = "Saturday"
End If
lblday.Caption = caption1$
End Sub
Private Sub lblnumber_click(Index As Integer)
Dim i%
On Error GoTo err1
For i% = 0 To 30
lblnumber(i%).BorderStyle = 0
Next i%
If lblnumber(Index).BorderStyle = 1 Then
lblnumber(Index).BorderStyle = 0
Else
lblnumber(Index).BorderStyle = 1
End If
selectedate% = Index + 1
Dim month1%, day1%, year1%, date1$
day1% = selectedate%
month1% = cbomonth.ListIndex + 1
year1% = cboyear.ListIndex + 1960
date1$ = (Str$(month1%) + "/" + Str$(day1%) + "/" + Str$(year1%))
'date1$ = Format$(date1$, "general date")
Dim r%
Dim caption1$
r% = WeekDay(date1$)
If r% = 1 Then
caption1$ = "Sunday"
ElseIf r% = 2 Then
caption1 = "Monday"
ElseIf r% = 3 Then
caption1 = "Tuesday"
ElseIf r% = 4 Then
caption1 = "Wednesday"
ElseIf r% = 5 Then
caption1 = "Thursday"
ElseIf r% = 6 Then
caption1 = "Friday"
Else
caption1 = "Saturday"
End If
lblday.Caption = caption1$
lbldate.Caption = Format$(date1$, "long date")
err1:
If Err = 0 Then Exit Sub
If Err = 13 Then
selectedate% = selectedate% - 1
Exit Sub
End If
End Sub
Private Sub setdate()
'since the list starts at 1960, this is 0, so we're going
' to get the date, and subtract 1960 from it, and use this
'as our starting listindex
'put whatever value you need to for the first year
'year
Dim r%, i%
r% = CInt(Format$(Now, "yyyy"))
i% = r% - 1960
cboyear.ListIndex = i%
'month
r% = CInt(Format$(Now, "mm"))
cbomonth.ListIndex = (r% - 1)
'day
r% = CInt(Format$(Now, "dd"))
lblnumber(r% - 1).BorderStyle = 1
selectedate% = r%
End Sub
Private Sub setday()
Dim month1%, year1%
month1% = determinemonth()
year1% = determineyear()
Call checkdate(month1%, year1%)
End Sub
